home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / report.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  117 lines
  1. ;;; "report.scm" relational-database-utility
  2. ; Copyright 1995 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;;; Considerations for report generation:
  21. ; * columnar vs. fixed-multi-line vs. variable-multi-line
  22. ; * overflow lines within column boundaries.
  23. ; * break overflow across page?
  24. ; * Page headers and footers (need to know current/previous record-number
  25. ;   and next record-number).
  26. ; * Force page break on general expression (needs next row as arg).
  27. ; * Hierachical reports.
  28.  
  29. ;================================================================
  30.  
  31. (require 'format)
  32. (require 'database-utilities)
  33.  
  34. (define (dbutil:database arg)
  35.   (cond ((procedure? arg) arg)
  36.     ((string? arg) (dbutil:open-database arg))
  37.     ((symbol? arg) (slib:eval arg))
  38.     (else (slib:error "can't coerce to database: " arg))))
  39.  
  40. (define (dbutil:table arg)
  41.   (cond ((procedure? arg) arg)
  42.     ((and (list? arg) (= 2 (length arg)))
  43.      (((dbutil:database (car arg)) 'open-table) (cadr arg) #f))))
  44.  
  45. (define (dbutil:print-report table header reporter footer . args)
  46.   (define output-port (and (pair? args) (car args)))
  47.   (define page-height (and (pair? args) (pair? (cdr args)) (cadr args)))
  48.   (define minimum-break
  49.     (and (pair? args) (pair? (cdr args)) (pair? (cddr args)) (caddr args)))
  50.   (set! table (dbutil:table table))
  51.   ((lambda (fun)
  52.      (cond ((output-port? output-port)
  53.         (fun output-port))
  54.        ((string? output-port)
  55.         (call-with-output-file output-port fun))
  56.        ((or (boolean? output-port) (null? output-port))
  57.         (fun (current-output-port)))
  58.        (else (slib:error "can't coerce to output-port: " arg))))
  59.    (lambda (output-port)
  60.      (set! page-height (or page-height (output-port-height output-port)))
  61.      (set! minimum-break (or minimum-break 0))
  62.      (let ((output-page 0)
  63.        (output-line 0)
  64.        (nth-newline-index
  65.         (lambda (str n)
  66.           (define len (string-length str))
  67.           (do ((i 0 (+ i 1)))
  68.           ((or (zero? n) (> i len)) (+ -1 i))
  69.         (cond ((char=? #\newline (string-ref str i))
  70.                (set! n (+ -1 n)))))))
  71.        (count-newlines
  72.         (lambda (str)
  73.           (define cnt 0)
  74.           (do ((i (+ -1 (string-length str)) (+ -1 i)))
  75.           ((negative? i) cnt)
  76.         (cond ((char=? #\newline (string-ref str i))
  77.                (set! cnt (+ 1 cnt)))))))
  78.        (format (let ((oformat format))
  79.              (lambda (dest fmt arg)
  80.                (cond ((not (procedure? fmt)) (oformat dest fmt arg))
  81.                  ((output-port? dest) (fmt dest arg))
  82.                  ((eq? #t dest) (fmt (current-output-port) arg))
  83.                  ((eq? #f dest) (call-with-output-string
  84.                          (lambda (port) (fmt port arg))))
  85.                  (else (oformat dest fmt arg)))))))
  86.        (define column-names (table 'column-names))
  87.        (define (do-header)
  88.      (let ((str (format #f header column-names)))
  89.        (display str output-port)
  90.        (set! output-line (count-newlines str))))
  91.        (define (do-lines str inc)
  92.      (cond
  93.       ((< (+ output-line inc) page-height)
  94.        (display str output-port)
  95.        (set! output-line (+ output-line inc)))
  96.       (else                ;outputting footer
  97.        (cond ((and (not (zero? minimum-break))
  98.                (> cnt (* 2 minimum-break))
  99.                (> (- page-height output-line) minimum-break))
  100.           (let ((break (nth-newline-index
  101.                 str (- page-height output-line))))
  102.             (display (substring str 0 (+ 1 break) output-port))
  103.             (set! str (substring str (+ 1 break) (string-length str)))
  104.             (set! inc (- inc (- page-height output-line))))))
  105.        (format output-port footer column-names)
  106.        (display slib:form-feed output-port)
  107.        (set! output-page (+ 1 output-page))
  108.        (do-header)
  109.        (do-lines str inc))))
  110.  
  111.        (do-header)
  112.        ((table 'for-each-row)
  113.     (lambda (row)
  114.       (let ((str (format #f reporter row)))
  115.         (do-lines str (count-newlines str)))))
  116.        output-page))))
  117.